perm filename NCNTRL.6[C,JRA] blob
sn#048368 filedate 1973-06-11 generic text, type T, neo UTF8
(SET (CAR (STATUS UREAD))(CADR (STATUS UREAD)))
(DECLARE (PRINT (LIST 'SETQ (CAR (STATUS UREAD)) (LIST 'QUOTE (CADR (STATUS UREAD))))))
(GLOBAL
(FUNCTIONS /@ EAR NEAR TOP CINTERRUPT VFRAME CPRINT CPRIN1 PROGBIND
RUN START STOP NOW PROG COND GO EXIT RETURN DISMISS CEVAL CERR
CDEFUN VLOC RVALUE CSET CSETQ TAG ACTBLOCK UNASSIGN ACCESS
CONTROL SETACCESS SETCONTROL EXPRESSION CLOSURE FRAME
CALL BACKTRACE LISTEN CONTINUE ALLOW INVOKE
/: /, /!/> /!/' /!/? /!/; /!/" /!/@ /!/< /!/,)
(RESERVED ← *FRAME CEXPR "OPTIONAL" "REST" "AUX"
* ** CLAMBDA ↑A *TAG *AU-REVOIR /? /< /> /' /@ /" /$ /; / / /) ))
(DECLARE (SPECIAL OBARRAY READTABLE ERRLIST) (SYMBOLS T) (MACROS T))
(DECLARE
(SPECIAL UARGS BODY EARGS CHALOBV BVARS ALINK CLINK
EXP FRAME* FREEVARS FRAMEVARS LEVNUM PC RUNF *TOP TEM
TEM1 TYPE VAL VARS CINTERRUPT STOPLEVEL ALLOW READY
GLOBALS * ** ← CREADF)
(*FEXPR CDEFGEN CDEFUN CERR CONNIVER CSETQ /: /@ /,)
(*LEXPR MATCH ACCESS CONTROL CSET RVALUE VLOC RUN))
(SETQ RUNF () STOPLEVEL () ** '** GLOBALS '((NIL NIL) (T T))) (COMMENT THE FRAME FORMAT IS AS FOLLOWS
((IVARS . PC) (BVARS . ALINK) EXP . CLINK)
)
(SETQ FREEVARS '(VAL VARS UARGS BODY EARGS TEM TEM1 ALLOW)
FRAMEVARS '(CHALOBV FRAME* BVARS ALINK CLINK EXP CINTERRUPT READY))
(DEFUN BVARS MACRO (L) (LIST 'CAADR (CADR L)))
(DEFUN ALINK MACRO (L) (LIST 'CDADR (CADR L)))
(DEFUN EXP MACRO (L) (LIST 'CADDR (CADR L)))
(DEFUN CLINK MACRO (L) (LIST 'CDDDR (CADR L)))
(DEFUN BODY MACRO (L) '(CADR (ASSQ '*BODY BVARS)))
(COMMENT THE HACK REALLY BEGINS HERE -- RUN1 IS THE SYSTEM DRIVER)
(DEFUN RUN L
(SETQ VAL (COND ((= L 1) (ARG 1)) (T NIL)))
(RUN1))
(DEFUN RUN1 ()
(COND (RUNF (CERR CONNIVER ALREADY RUNNING)) )
((LAMBDA (BASE IBASE READTABLE)
(PROG (RUNF ERET)
(SETQ RUNF T)
(SSTATUS TOPLEVEL STOPLEVEL)
ERRL (SETQ ERET
(CATCH (PROG ()
LOOP (COND ((AND CINTERRUPT ALLOW)
(SETQ PC (HANDLE)))
((SETQ PC (CAP PC))))
(GO LOOP))))
(COND ((EQ ERET 'STOP) (RETURN VAL)))
(GO ERRL)))
10.
10.
(GET 'CONNIVREAD 'ARRAY)) )
(DEFUN CAP (P) (APPLY P ()))
(DEFUN HANDLE ()
(DISPATCH (PROG2 (PI-OFF)
(CAR CINTERRUPT)
(SETQ CINTERRUPT (CDR CINTERRUPT))
(PI-ON))
PC
FREEVARS
'*TOP))
(DEFUN START NIL
(INIT)
(RUN1) )
(DEFUN INIT ()
(COND (RUNF (CERR CONNIVER ALREADY RUNNING)))
(MAPC '(LAMBDA (V) (SET V NIL)) (APPEND FRAMEVARS FREEVARS))
(SETQ PC 'ICEVAL
EXP '(CEVAL '(LISTEN 'TOP-LEVEL))
LEVNUM 0
CREADF NIL
*TOP NIL))
(DEFUN STOP N
(BREAK CONNIVER-NOT-RUNNING--STOP (NOT RUNF))
(COND ((= N 0) (SETQ VAL ()))
((= N 1) (SETQ VAL (ARG 1)))
(T (CERR WRONG # OF ARGS)))
(SETQ PC 'POPJ)
(THROW 'STOP))
(DEFUN *STOP NIL (SETQ PC 'U-LOSE) (THROW 'STOP))
(DEFUN U-LOSE NIL
(CERR ATTEMPT TO RUN A CONNIVER PROCESS WITH AN UNDEFINED PC)
'U-LOSE)
(DEFUN CERR FEXPR (L A)
(PROG (↑Q ↑W ANS)
(PRINT '**ERROR**)
(COMP L A)
(CPRIN1 EXP)
(COND ((SETQ ANS (LOOP A)) (RETURN ANS)))
(NEAR)))
(DEFUN CBREAK FEXPR (L A)
(PROG (↑Q ↑W)
(TERPRI)
(COMP L A)
(RETURN (LOOP A))))
(DEFUN COMP (COMMENT ALIST)
(MAPC '(LAMBDA (X)
(CPRIN1 (COND ((ATOM X) X)
((EQ (CAR X) '/@) (EVAL (CDR X) ALIST))
(T X)))
(PRINC '/ ))
COMMENT))
(DEFUN LOOP (ALIST)
(PROG (PISTATUS)
(PRINT 'IN-LISP)
(SETQ PISTATUS (PI-ON))
LP (ERRSET (COND ((EQ (CATCH (CREAD '*)) 'CREAD))
((EQ ** '≠P)
(AND PISTATUS (PI-OFF))
(RETURN NIL))
((EQ (CAR **) 'RETURN)
(AND PISTATUS (PI-OFF))
(RETURN (EVAL (CADR **) ALIST)))
(T (CP (EVAL ** ALIST)))))
(GO LP)))
(DEFUN EAR ()
(NOW '(LISTEN 'IN-CONNIVER))
(SETQ STOPLEVEL (STATUS TOPLEVEL))
(SSTATUS TOPLEVEL '(RUN1))
(IOC G))
(DEFUN NEAR ()
(NOW '(GO 'EAR))
(SETQ STOPLEVEL (STATUS TOPLEVEL))
(SSTATUS TOPLEVEL '(RUN1))
(IOC G) )
(DEFUN TOP ()
(SETQ STOPLEVEL (STATUS TOPLEVEL))
(SSTATUS TOPLEVEL '(START))
(IOC G))
(DEFUN NOW (EXP)
(PI-OFF)
(NCONC (GET 'CINTERRUPT 'VALUE) (LIST EXP))
(PI-ON))
(DEFUN CINTERRUPT (EXP)
(PI-OFF)
(SETQ CINTERRUPT (CONS EXP CINTERRUPT))
(PI-ON))
(DEFUN ALLOW FEXPR (L) (SETQ ALLOW (CAR L))) (COMMENT DISPATCH IS THE "PUSHJ" FOR CONNIVER)
(DECLARE (SPECIAL ALINK1 EXP1 RETAG SAVE))
(DEFUN DISPATCH
(EXP1 RETAG SAVE ALINK1)
(COND ((NUMBERP EXP1) (SETQ VAL EXP1) RETAG)
((ATOM EXP1) (SETQ VAL (IVAL EXP1 ALINK1)) RETAG)
(T (PROG (V F)
(SETQ F (CAR EXP1))
BEGIN
(COND ((ATOM F)
(COND ((SETQ V
(GETL F '(CINT CEXPR FEXPR FSUBR)))
(GO (CAR V)))
(T (SAVEUP)
(SETQ UARGS (CDR EXP1) EARGS ())
(RETURN 'EVARGS))))
((EQ (CAR F) 'CLAMBDA)
(SAVEUP)
(BIND1 '*BODY (CDDR F))
(SETQ VARS (CADR F) UARGS (CDR EXP1))
(RETURN 'ARGB))
((EQ (CAR F) 'LAMBDA)
(SAVEUP)
(SETQ UARGS (CDR EXP1) EARGS ())
(RETURN 'EVARGS))
((EQ (CAR F) '*CLOSURE)
(SETQ F (CADR F))
(GO BEGIN))
(T (SETQ F (CERR UNKNOWN FUNCTION TYPE (/@ . EXP1)))
(GO BEGIN)))
CINT
(SAVEUP)
(RETURN (CADR V))
CEXPR
(SAVEUP)
(BIND1 '*BODY (CDADR V))
(SETQ VARS (CAADR V) UARGS (CDR EXP1))
(RETURN 'ARGB)
FEXPR FSUBR
((LAMBDA (*TOP) (SETQ VAL (EVAL EXP1))) ALINK1)
(RETURN RETAG)))))
(DEFUN SAVEUP ()
(SETQ
CLINK (CONS (CONS (SAVEV) RETAG)
(COND ((NULL FRAME*) (SETQ CHALOBV NIL)
(CONS (CONS BVARS ALINK) (CONS EXP CLINK)))
(CHALOBV (SETQ CHALOBV NIL)
(CONS (CONS BVARS ALINK) (CDDR FRAME*)))
(T (CDR FRAME*))))
EXP EXP1
ALINK (COND ((EQ ALINK1 '*TOP) CLINK) (T ALINK1))
BVARS NIL
FRAME* NIL))
(DEFUN SAVEV () (MAPCAR '(LAMBDA (V) (CONS V (VALUE V))) SAVE)) (COMMENT FUNCTION CALLS RETURN VIA "POPJ")
(DEFUN POPJ ()
(COND ((SETQ FRAME* CLINK) (RESTORE))
(T '*STOP)))
(DEFUN RESTORE ()
(SETQ
BVARS (CAADR FRAME*)
ALINK (CDADR FRAME*)
EXP (CADDR FRAME*)
CLINK (CDDDR FRAME*))
(REST1))
(DEFUN REST1 ()
(MAPC '(LAMBDA (X) (SET (CAR X) (CDR X))) (CAAR FRAME*))
(CDAR FRAME*))
(PUTPROP 'VALUE (GET 'EVAL 'LSUBR) 'LSUBR)
(DECLARE (UNSPECIAL ALINK1 EXP1 RETAG SAVE))
(DEFUN BIND1 (VAR VAL)
(SETQ BVARS (CONS (LIST VAR VAL) BVARS) CHALOBV T))
(DEFUN CLOSE ()
(COND ((ATOM (CAR EXP)))
((EQ (CAAR EXP) '*CLOSURE)
(SETQ ALINK (CADDAR EXP) CHALOBV T))))
(COMMENT MOBY BINDER -- NORMAL FUNCTION LISTS)
(DEFUN ARGB NIL (COND ((NOT (OR VARS UARGS)) (CLOSE) 'AUXB)
((AND VARS UARGS)
(COND ((ATOM (CAR VARS))
(COND ((EQ (CAR VARS) '"OPTIONAL")
(SETQ VARS (CDR VARS))
(OPTMATCH))
((EQ (CAR VARS) '"REST")
(SETQ VARS (CDR VARS))
(RESTMATCH))
(T (DISPATCH (CAR UARGS)
'ARGB1
'(VARS UARGS)
ALINK))))
((AND (EQ (CAAR VARS) 'QUOTE)
(ATOM (CADAR VARS)))
(ARGQ))
(T (CERR BAD DECLARATION))))
((AND VARS (OR (EQ (CAR VARS) '"OPTIONAL")
(EQ (CAR VARS) '"REST")))
(CLOSE)
(FINVAR))
(T (CERR WRONG # OF ARGS))))
(DEFUN ARGB1
NIL
(BIND1 (CAR VARS) VAL)
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'ARGB)
(DEFUN ARGQ
NIL
(BIND1 (CADAR VARS) (CAR UARGS))
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'ARGB)
(COMMENT BIND UP "OPTIONAL"S AND "REST"S)
(DEFUN OPTMATCH
NIL
(COND ((NULL UARGS) (CLOSE) (COND ((NULL VARS) 'AUXB)
(T 'FINVAR)))
((ATOM (CAR VARS)) (COND ((EQ (CAR VARS) '"OPTIONAL")
(SETQ VARS (CDR VARS))
'OPTMATCH)
((EQ (CAR VARS) '"REST")
(SETQ VARS (CDR VARS))
'RESTMATCH)
(T (DISPATCH (CAR UARGS)
'OPTMATCH1
'(VARS UARGS)
ALINK))))
((EQ (CAAR VARS) 'QUOTE)
(COND ((ATOM (CADAR VARS)) (BIND1 (CADAR VARS) (CAR UARGS))
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'OPTMATCH)
(T (CERR BAD DECLARATION))))
((ATOM (CAAR VARS)) (DISPATCH (CAR UARGS)
'OPTMATCH1
'(VARS UARGS)
ALINK))
((AND (EQ (CAAAR VARS) 'QUOTE) (ATOM (CADAAR VARS)))
(BIND1 (CADAAR VARS) (CAR UARGS))
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'OPTMATCH)
(T (CERR BAD DECLARATION))))
(DEFUN OPTMATCH1
NIL
(BIND1 (COND ((ATOM (CAR VARS)) (CAR VARS)) (T (CAAR VARS))) VAL)
(SETQ VARS (CDR VARS) UARGS (CDR UARGS))
'OPTMATCH)
(DEFUN RESTMATCH NIL (COND ((ATOM (CAR VARS)) (SETQ EARGS NIL) (EVREST))
((AND (EQ (CAAR VARS) 'QUOTE)
(ATOM (CADAR VARS)))
(BIND1 (CADAR VARS) UARGS)
(CLOSE) 'AUXB)
(T (CERR BAD DECLARATION))))
(DEFUN EVREST NIL (COND ((NULL UARGS)
(BIND1 (CAR VARS) (REVERSE EARGS))
(CLOSE) 'AUXB)
(T (DISPATCH (CAR UARGS)
'EVREST1
'(VARS UARGS EARGS)
ALINK))))
(DEFUN EVREST1 NIL (SETQ UARGS (CDR UARGS) EARGS (CONS VAL EARGS)) 'EVREST)
(COMMENT WHEN RUN OUT OF ARGS BUT HAVE SOME "OPTIONAL"S OR "REST"S)
(DEFUN FINVAR ()
(COND ((NULL VARS) 'AUXB)
((ATOM (CAR VARS))
(COND ((EQ (CAR VARS) '"OPTIONAL") (SETQ VARS (CDR VARS))
'FINVAR)
((EQ (CAR VARS) '"REST")
(SETQ VARS (CDR VARS))
(COND ((ATOM (CAR VARS)) (BIND1 (CAR VARS) NIL) 'AUXB)
((AND (EQ (CAAR VARS) 'QUOTE)
(ATOM (CADAR VARS)))
(BIND1 (CADAR VARS) NIL)
'AUXB)
(T (CERR BAD DECLARATION))))
(T (BIND1 (CAR VARS) '*UNASSIGNED)
(SETQ VARS (CDR VARS))
'FINVAR)))
((EQ (CAAR VARS) 'QUOTE)
(COND ((ATOM (CADAR VARS))
(BIND1 (CADAR VARS) '*UNASSIGNED)
(SETQ VARS (CDR VARS))
'FINVAR)
(T (CERR BAD DECLARATION))))
((ATOM (CAAR VARS))
(DISPATCH (CADAR VARS) 'FINVAR1 '(VARS) '*TOP))
((AND (EQ (CAAAR VARS) 'QUOTE) (ATOM (CADAAR VARS)))
(DISPATCH (CADAR VARS) 'FINVAR2 '(VARS) '*TOP))
(T (CERR BAD DECLARATION))))
(DEFUN FINVAR1 NIL (BIND1 (CAAR VARS) VAL) (FINVAR3))
(DEFUN FINVAR2 NIL (BIND1 (CADAAR VARS) VAL) (FINVAR3))
(DEFUN FINVAR3 NIL (SETQ VARS (CDR VARS)) 'FINVAR)
(COMMENT BINDS "AUX" VARIABLES)
(DEFUN AUXB ()
(SETQ BODY (BODY))
(COND ((NULL BODY) (POPJ))
((EQ (CAR BODY) '"AUX")
(SETQ VARS (CADR BODY))
'AUXB1)
(T 'LINE)))
(DEFUN AUXB1 NIL (COND ((NULL VARS) (SETQ BODY (CDDR (BODY))) 'LINE)
((ATOM (CAR VARS)) (BIND1 (CAR VARS) '*UNASSIGNED)
(SETQ VARS (CDR VARS))
'AUXB1)
((AND (ATOM (CAAR VARS)) (CDAR VARS))
(DISPATCH (CADAR VARS)
'AUXB2
'(VARS)
'*TOP))
(T (CERR BAD DECLARATION))))
(DEFUN AUXB2 NIL (BIND1 (CAAR VARS) VAL) (SETQ VARS (CDR VARS)) 'AUXB1)
(DEFUN CPROG NIL (BIND1 '*BODY (CDR EXP)) 'AUXB)
(DEFPROP PROG CPROG CINT)
(DEFUN PROGBIND () (DISPATCH (CADR EXP) 'PROGB1 NIL ALINK))
(DEFUN PROGB1 ()
(BIND1 '*BODY (CONS '"AUX" (CONS (SETQ VARS VAL) (CDDR EXP))))
'AUXB1)
(DEFPROP PROGBIND PROGBIND CINT)
(COMMENT BASIC PROG ITERATION LOOP)
(DEFUN LINE ()
(COND ((NULL BODY) (POPJ))
(T (DISPATCH (CAR BODY) 'LINE1 '(BODY) '*TOP))))
(DEFUN LINE1 NIL (SETQ BODY (CDR BODY)) 'LINE)
(COMMENT EVALUATES ARGUMENTS TO LISP EXPRS SUBRS AND LSUBRS)
(DEFUN EVARGS ()
(COND ((NULL UARGS)
((LAMBDA (*TOP)
(SETQ VAL (APPLY (CAR EXP) (REVERSE EARGS))))
ALINK)
(POPJ))
(T (DISPATCH (CAR UARGS) 'ARGS1 '(UARGS EARGS) ALINK))))
(DEFUN ARGS1 ()
(SETQ UARGS (CDR UARGS) EARGS (CONS VAL EARGS)) 'EVARGS)
(COMMENT LOGICAL FLOW OF CONTROL FUNCTIONS)
(DEFUN CCOND () (SETQ UARGS (CDR EXP)) (CONDLP))
(DEFUN CONDLP ()
(COND ((NULL UARGS) (POPJ))
(T (DISPATCH (CAAR UARGS) 'COND1 '(UARGS) ALINK))))
(DEFUN COND1 NIL (COND (VAL (BIND1 '*BODY (CDAR UARGS)) 'AUXB)
(T (SETQ UARGS (CDR UARGS)) 'CONDLP)))
(DEFPROP COND CCOND CINT)
(DEFUN IAND ()
(COND ((NULL (SETQ EXP (CDR EXP))) (OR VAL (SETQ VAL T)) (POPJ))
((DISPATCH (CAR EXP) 'IAND1 '(EXP) '*TOP)) ))
(DEFUN IAND1 ()
(COND (VAL 'IAND)
('POPJ) ))
(DEFPROP AND IAND CINT)
(DEFUN IOR ()
(COND ((NULL (SETQ EXP (CDR EXP))) (SETQ VAL NIL) (POPJ))
((DISPATCH (CAR EXP) 'IOR1 '(EXP) '*TOP)) ))
(DEFUN IOR1 ()
(COND (VAL (POPJ))
(T 'IOR) ))
(DEFPROP OR IOR CINT)
(COMMENT USERS OF FRAMES -- FLOW OF CONTROL CONTROLLERS)
(DEFUN CGO NIL (DISPATCH (CADR EXP) 'GO1 NIL ALINK))
(DEFUN GO1 ()
(COND ((ATOM VAL)
(PROG (FR TAG B)
(SETQ FR ALINK TAG '(/: FOO))
(RPLACA (CDR TAG) VAL)
LP (COND ((NULL FR) (SETQ VAL (CERR TAG NOT FOUND)) 'GO1)
((SETQ B (ASSQ '*BODY (BVARS FR)))
(COND ((SETQ B (MEMBER TAG (CADR B)))
(SETQ FRAME* FR)
(RESTORE)
(SETQ BODY B)
(RETURN 'LINE)))))
(SETQ FR (CLINK FR))
(GO LP)))
((EQ (CAR VAL) '*TAG)
(SETQ FRAME* (CADDR VAL))
(RESTORE))
(T (SETQ VAL (CERR BAD TAG)) 'GO1)))
(DEFPROP GO CGO CINT)
(DEFUN CEXIT NIL (DISPATCH (CADR EXP) 'EXIT1 () ALINK))
(DEFUN EXIT1 ()
(SETQ TEM VAL)
(COND ((CDDR EXP)
(DISPATCH (CADDR EXP) 'EXIT2 '(TEM) ALINK))
(T (PROG (FR)
(SETQ FR ALINK)
LP (COND ((NULL FR) (CERR EXIT FROM WHAT?))
((ASSQ '*BODY (BVARS FR))
(SETQ CLINK (CLINK FR))
(RETURN (POPJ))))
(SETQ FR (CLINK FR))
(GO LP)))))
(DEFUN EXIT2 ()
(SETQ CLINK (CLINK (FR VAL)) VAL TEM)
(POPJ))
(DEFPROP EXIT CEXIT CINT)
(DEFUN CRETURN NIL (DISPATCH (CADR EXP) 'RETURN1 NIL ALINK))
(DEFUN RETURN1 NIL (PROG (FR)
(SETQ FR ALINK)
LP (COND ((NULL FR) (CERR RETURN FROM WHAT?))
((AND (ASSQ '*BODY (BVARS FR))
(NOT (EQ (CAR (EXP FR)) 'COND)))
(SETQ CLINK (CLINK FR))
(RETURN (POPJ))))
(SETQ FR (CLINK FR))
(GO LP)))
(DEFPROP RETURN CRETURN CINT) (DEFUN CDISMISS NIL (COND ((CDR EXP)
(SETQ TEM ())
(DISPATCH (CADR EXP) 'EXIT2 '(TEM) ALINK))
(T (SETQ VAL ()) (RETURN1))))
(DEFPROP DISMISS CDISMISS CINT)
(DEFUN CONTINUE () (DISPATCH (CADR EXP) 'CONT1 () ALINK))
(DEFUN CONT1 ()
(SETQ TEM VAL)
(COND ((CDDR EXP) (DISPATCH (CADDR EXP) 'CONT2 '(TEM) ALINK))
(T (SETQ VAL () FRAME* (FR TEM)) (RESTORE))))
(DEFUN CONT2 () (SETQ FRAME* (FR TEM)) (RESTORE))
(DEFPROP CONTINUE CONTINUE CINT) (COMMENT RELATIVE EVALUATORS)
(DEFUN ICEVAL NIL (DISPATCH (CADR EXP) 'CEVAL1 () ALINK))
(DEFUN CEVAL1 ()
(SETQ TEM1 VAL)
(COND ((CDDR EXP)
(DISPATCH (CADDR EXP) 'CEVAL2 '(TEM1) ALINK))
(T (SETQ VAL (FRAME)) 'CEVAL2)))
(DEFUN CEVAL2 ()
(DISPATCH TEM1 'POPJ NIL (FR VAL)))
(DEFPROP CEVAL ICEVAL CINT)
(DEFUN ICALL NIL (DISPATCH (CADR EXP) 'CALL1 NIL ALINK))
(DEFUN CALL1 () (DISPATCH (CONS VAL (CDDR EXP)) 'POPJ NIL ALINK))
(DEFPROP CALL ICALL CINT)
(DEFUN INVOKE () (DISPATCH (CADR EXP) 'TRY1 () ALINK))
(DEFUN TRY1 () (SETQ TEM VAL) (DISPATCH (CADDR EXP) 'TRY2 '(TEM) ALINK))
(DEFUN TRY2 ()
(SETQ EXP (LIST TEM VAL) FRAME* NIL)
(PROG (AL METHPAT)
(COND ((NULL (SETQ AL (MATCH (SETQ METHPAT (PATTERN TEM)) VAL)))
(SETQ VAL NIL)
(RETURN (POPJ)))
(T (SETQ BVARS (NCONC (LIST (LIST '*CALLPAT VAL)
(LIST '*METHPAT METHPAT)
(LIST '*CALLALIST (CADR AL))
(LIST '*BODY (TEXT TEM)))
(CAR AL)))
(CLOSE)
(RETURN 'AUXB)))))
(DEFPROP INVOKE INVOKE CINT)
(DEFUN TEXT (METH)
(COND ((ATOM METH) (TEXT (GET METH 'DATUM)))
((EQ (CAR METH) '*CLOSURE) (TEXT (CADR METH)))
(T (CADDDR METH))))
(DEFUN FR (E)
(COND ((EQ (CAR E) '*FRAME) (CADR E))
((EQ (CAR E) '*TAG) (CADDR E))
((EQ (CAR E) '*CLOSURE) (CADDR E))
((EQ (CAR E) '*AU-REVOIR) (CADR E))
(T (CERR BAD FRAME SUPPLIED)))) (COMMENT IDENTIFIER MANIPULATORS)
(DEFUN VFRAME N
(PROG (FR LOC)
(SETQ FR (COND ((= N 1) ALINK)
((= N 2) (FR (ARG 2)))
(T (CERR WRONG # OF ARGS))))
LP (COND ((NULL FR) (RETURN NIL))
((SETQ LOC (ASSQ (ARG 1) (BVARS FR)))
(RETURN (LIST '*FRAME (CHAUX FR) LOC))))
(SETQ FR (ALINK FR))
(GO LP)))
(DEFUN VLOC N (PROG (FR LOC)
(SETQ FR (COND ((= N 1.)
(COND ((SETQ LOC (ASSQ (ARG 1)
BVARS))
(RETURN LOC)))
ALINK)
((= N 2.) (FR (ARG 2.)))
(T (CERR WRONG # OF ARGS))))
LP (COND ((NULL FR) (RETURN (ASSQ (ARG 1) GLOBALS)))
((SETQ LOC (ASSQ (ARG 1.) (BVARS FR)))
(RETURN LOC)))
(SETQ FR (ALINK FR))
(GO LP)))
(DEFUN RVALUE N
((LAMBDA (LOC)
(COND (LOC (COND ((CDDR LOC) (APPLY (CADDR LOC) (LIST 'RVALUE LOC))))
(CADR LOC))
(T (CERR UNBOUND VARIABLE @(ARG 1)))))
(COND ((= N 1.) (VLOC (ARG 1.)))
((= N 2.) (VLOC (ARG 1.) (ARG 2.)))
(T (CERR WRONG # OF ARGS)))))
(DECLARE (SPECIAL ID))
(DEFUN IVAL (ID FR)
(PROG (ANS)
(COND ((EQ FR '*TOP)
(COND ((SETQ ANS (ASSQ ID BVARS))
(GO FOUND))
(T (SETQ FR ALINK)))))
LP (COND ((NULL FR)
(COND ((SETQ ANS (ASSQ ID GLOBALS)) (GO FOUND))
(T (RETURN (CERR UNBOUND VARIABLE (/@ . ID))))))
((SETQ ANS (ASSQ ID (BVARS FR))) (GO FOUND)))
(SETQ FR (ALINK FR))
(GO LP)
FOUND
(COND ((CDDR ANS) (APPLY (CADDR ANS) (LIST '/, ANS))))
(COND ((EQ (SETQ ANS (CADR ANS)) '*UNASSIGNED)
(RETURN (CERR UNASSIGNED VARIABLE (/@ . ID)))))
(RETURN ANS)))
(DECLARE (UNSPECIAL ID))
(DEFUN ICSETQ () (SETQ UARGS EXP)(CSETQ0))
(DEFUN CSETQ0 ()
(COND ((CDR UARGS)
(COND ((AND (ATOM (CADR UARGS)) (CDDR UARGS))
(DISPATCH (CADDR UARGS) 'CSETQ1 '(UARGS) ALINK))
(T (CERR BAD CALL) (POPJ))))
(T (POPJ))))
(DEFUN CSETQ1 ()
((LAMBDA (LOC)
(COND (LOC (COND ((CDDR LOC) (APPLY (CADDR LOC) (LIST 'CSET LOC VAL))))
(RPLACA (CDR LOC) VAL))
(T (SETQ GLOBALS (CONS (LIST (CADR UARGS) VAL) GLOBALS)))))
(VLOC (CADR UARGS)))
(SETQ UARGS (CDDR UARGS))
'CSETQ0)
(DEFUN CSETQ FEXPR (L)
(CSET (CAR L) (EVAL (CADR L))) )
(DEFPROP CSETQ ICSETQ CINT)
(DEFUN CSET N
((LAMBDA (LOC)
(COND (LOC (COND ((CDDR LOC) (APPLY (CADDR LOC) (LIST 'CSET LOC (ARG 2)))))
(RPLACA (CDR LOC) (ARG 2.)))
(T (SETQ GLOBALS (CONS (LIST (ARG 1) (ARG 2)) GLOBALS))))
(ARG 2.))
(COND ((= N 2.) (VLOC (ARG 1.)))
((= N 3.) (VLOC (ARG 1.) (ARG 3.)))
(T (CERR WRONG # OF ARGS)))))
(DEFUN UNASSIGN (VAR) (CSET VAR '*UNASSIGNED)) (COMMENT FRAME CONSTRUCTORS)
(DEFUN CHAUX (FR)
(COND ((NULL FR) NIL)
((EQ (CDAR FR) 'AUXB1)
(CERR ATTEMPT TO RETURN INCOMPLETE FRAME))
(T FR)))
(DEFUN TAG (NAME)
(PROG (FR B TAG)
(SETQ FR ALINK TAG '(/: FOO))
(RPLACA (CDR TAG) NAME)
LP (COND ((NULL FR) (RETURN NIL))
((SETQ B (ASSQ '*BODY (BVARS FR)))
(COND ((SETQ B (MEMBER TAG (CADR B)))
(CHAUX FR)
(RETURN (LIST '*TAG NAME
(CONS (CONS (LIST (CONS 'BODY B))
'LINE)
(CDR FR))))))))
(SETQ FR (CLINK FR))
(GO LP)))
(DEFUN ACTBLOCK ()
(PROG (FR B)
(SETQ FR ALINK)
LP (COND ((NULL FR) (RETURN ()))
((SETQ B (ASSQ '*BODY (BVARS FR)))
(CHAUX FR)
(COND ((EQ (CAR B) '"AUX") (SETQ B (CDDR B))))
(RETURN (LIST '*TAG '*ACTBLOCK
(CONS (CONS (LIST (CONS 'BODY B)) 'LINE)
(CDR FR))))))
(SETQ FR (CLINK FR))
(GO LP)))
(DEFUN ACCESS N
(LIST '*FRAME
(CHAUX (COND ((= N 0.) (ALINK ALINK))
((= N 1.) (ALINK (FR (ARG 1.))))
(T (CERR WRONG # OF ARGS))))))
(DEFUN CONTROL N
(LIST '*FRAME
(CHAUX (COND ((= N 0.) (CLINK ALINK))
((= N 1.) (CLINK (FR (ARG 1))))
(T (CERR WRONG # OF ARGS))))))
(DEFUN CLOSURE N
(COND ((OR (< N 1) (> N 2)) (CERR WRONG # OF ARGS)) )
(LIST '*CLOSURE (ARG 1) (CHAUX (COND ((= N 2) (FR (ARG 2)))
(T ALINK)) )) )
(DEFUN FRAME NIL (LIST '*FRAME (CHAUX ALINK))) (COMMENT VERY DANGEROUS USER (HA!) FUNCTIONS)
(DEFUN SETACCESS (T1 S)
(SETQ T1 (FR T1) S (FR S))
(RPLACD (CADR T1) S)
'BOOM!)
(DEFUN SETCONTROL (T1 S)
(SETQ T1 (FR T1) S (FR S))
(RPLACD (CDDR T1) S)
'BOOM!)
(DEFUN CEVAL N
((LAMBDA (PC EXP ALINK)
(PROG (CLINK FRAME* BVARS CHALOBV RUNF) (RETURN (RUN1))))
'ICEVAL
(LIST 'CEVAL (LIST 'QUOTE (ARG 1)))
(COND ((> N 1) (FR (ARG 2))) (T ALINK)))) (COMMENT DEBUGGING AIDS)
(DEFUN EXPRESSION (F) (EXP (FR F)))
(DEFUN BACKTRACE N (PROG (FR E B M TEM)
(SETQ FR (FRAME))
(COND ((= N 0.) (SETQ M 262143.))
(T (SETQ M (ARG 1.))))
(COND ((= N 2.) (SETQ TEM (ARG 2.))))
LP (COND ((OR (NULL (CADR FR)) (= M 0.))
(RETURN 'END-OF-BACKTRACE)))
(SETQ E (EXPRESSION FR))
(COND ((SETQ B (GET (CAR E) 'BACKTRACE))
(APPLY B (LIST FR (CDR E))))
(T (CPRINT E)))
(COND (TEM (CPRIN1 (CAADR FR))))
(SETQ FR (CONTROL FR))
(SETQ M (/1- M))
(GO LP)))
(DEFUN LISTENB
(FR ARG)
(PRINT (IVAL 'EAR (CADR FR)))
(CPRIN1 (IVAL 'MESSAGE (CADR FR)))
(PRINC '/ ))
(DEFPROP LISTEN LISTENB BACKTRACE)
(DEFUN CONDB (FR ARG) (PRINT 'COND))
(DEFPROP COND CONDB BACKTRACE)
(DEFUN PROGB (FR ARG) (PRINT 'PROG))
(DEFPROP PROG PROGB BACKTRACE)
(DEFUN CEVALB (FR ARG) (COND (TEM (PRINT 'CEVAL))))
(DEFPROP CEVAL CEVALB BACKTRACE)
(DEFPROP CP CPB BACKTRACE)
(DEFUN CPB (FR ARG) ())
(DEFUN PROGBINDB (FR ARG) (PRINT 'PROGBIND))
(DEFPROP PROGBIND PROGBINDB BACKTRACE)
(COMMENT USER INTERFACE)
(DEFUN CDEFUN FEXPR (L) (PUTPROP (CAR L) (CDR L) 'CEXPR) (CAR L))
(CDEFUN LISTEN (MESSAGE) "AUX"((EAR (GENLEV)))
(ALLOW T)
(CPRINT MESSAGE)
(PROGBIND (LIST EAR 'LOOP)
(CSET EAR (TAG 'EAR))
(CSETQ LOOP (TAG 'LOOP))
(/: EAR)
(PRINT EAR)
(/: LOOP)
(CREAD '/←)
(CP (CEVAL (/@ . **)))
(GO LOOP)))
(DEFUN CREAD (PROMPT)
(PROG (CREADF)
(PRINC '/
/
)
(PRINC PROMPT)
(SETQ ← ** CREADF 'CREAD ** (READ))))
(DEFUN CP (X) (SETQ * X) (CPRINT X))
(DEFUN GENLEV NIL (READLIST (APPEND '(E A R -)
(EXPLODE (SETQ LEVNUM (ADD1 LEVNUM))))))
(DEFUN /: FEXPR (L) L)
(DEFUN /@ FEXPR (\L) (EVAL \L))
(DEFUN /, FEXPR (L) (IVAL (CAR L) *TOP))
(DEFUN ↑A (X)
(PROG (FUN ↑Q ↑W)
(TYIPEEK 1)
(TYI)
(SETQ X (READCH))
(COND ((SETQ FUN (GET X '↑A)) (FUN X))
(T (PRINC '/?)))))
(SSTATUS INTERRUPT 2 '↑A)
(DEFPROP X ↑AX ↑A)
(DEFUN ↑AX (X) (CPRINT EXP))
(DEFPROP T ↑AT ↑A)
(DEFUN ↑AT (X) (TOP))
(DEFPROP F ↑AF ↑A)
(DEFUN ↑AF (X) (COND (CREADF (THROW 'CREAD)) (T (PRINC '/?))))
(DEFPROP E ↑AE ↑A)
(DEFUN ↑AE (X) (NOW '(LISTEN '↑AE)))
(DEFPROP N ↑AN ↑A)
(DEFUN ↑AN (X) (NOW '(GO 'EAR)))
(DEFPROP L ↑AL ↑A)
(DEFUN ↑AL (X) (CBREAK '↑AL)) (DEFUN CPRIN1 (X)
(PROG (Y)
(COND ((ATOM X) (PRIN1 X) (RETURN X))
((AND (ATOM (CAR X)) (SETQ Y (GET (CAR X) 'CPRINT)))
(APPLY Y X) (RETURN X)))
(SETQ Y X)
(PRINC '/()
PLOOP
(CPRIN1 (CAR Y))
(COND ((NULL (SETQ Y (CDR Y))) (PRINC '/)) (RETURN X))
((OR (ATOM Y)
(AND (ATOM (CAR Y)) (GET (CAR Y) 'CPRINT)))
(PRINC '/ /./ )
(CPRIN1 Y)
(PRINC '/))
(RETURN X)))
(PRINC '/ )
(GO PLOOP)))
(DEFUN CPRINT (X) (PRINC '/
/
) (CPRIN1 X) (PRINC '/ ) X)
(DEFUN CP-MACR FEXPR (E) (PRINC (CAR E)) (PRIN1 (CADR E)))
(DEFPROP /: CP-MACR CPRINT)
(DEFPROP /, CP-MACR CPRINT)
(DEFUN CP-QUOTE FEXPR (E) (PRINC '/') (CPRIN1 (CADR E)))
(DEFPROP QUOTE CP-QUOTE CPRINT)
(DEFUN CP-*TAG FEXPR (TAG)
(PRINC '/()
(PRIN1 (CAR TAG))
(PRINC '/ )
(CPRIN1 (CADR TAG))
(PRINC '/ )
(CPRIN1 (EXP (CADDR TAG)))
(PRINC '/)))
(DEFPROP *TAG CP-*TAG CPRINT)
(DEFPROP *CLOSURE CP-*TAG CPRINT)
(DEFUN CP-*FRAME FEXPR (FRAME)
(PRINC '/()
(PRIN1 (CAR FRAME))
(PRINC '/ )
(CPRIN1 (EXP (CADR FRAME)))
(PRINC '/)))
(DEFPROP *FRAME CP-*FRAME CPRINT)
(DEFPROP *AU-REVOIR CP-*FRAME CPRINT)
(DEFUN CP-MATCH FEXPR (E)
(PRINC (CAR E))
(COND ((CDDR E) (CPRIN1 (CDR E)))
((CADR E) (CPRIN1 (CADR E)) )))
(DEFPROP /!/> CP-MATCH CPRINT)
(DEFPROP /!/' CP-MATCH CPRINT)
(DEFPROP /!/? CP-MATCH CPRINT)
(DEFPROP /!/; CP-MATCH CPRINT)
(DEFPROP /!/< CP-MATCH CPRINT)
(DEFPROP /!/, CP-MATCH CPRINT)
(DEFPROP /!/@ CP-MATCH CPRINT)
(DEFUN CP-/!/" FEXPR (E) (PRINC (CAR E)) (CPRIN1 (CDR E)))
(DEFPROP /!/" CP-/!/" CPRINT)
(DEFPROP /@ CP-/!/" CPRINT) (DEFUN COLMAC NIL (LIST '/: (READ)))
(DEFUN COMMAC () (LIST '/, (READ)))
(DEFUN ATMAC () (CONS '/@ (READ)))
(DEFUN EXMAC ()
(PROG (C F)
(SETQ C (NXTCHR))
(COND ((EQ C '/$) (TYI)
(RETURN ((LAMBDA (OBARRAY) (READ))
(GET 'CONNIVER 'ARRAY))))
((SETQ F (ASSQ C '((/" /!/") (/@ /!/@))))
(TYI)
(RETURN (CONS (CADR F) (READ))))
((SETQ F (ASSQ C '((/? /!/?) (/' /!/') (/> /!/>)
(/, /!/,) (/< /!/<) (/; /!/;))))
(TYI)
(SETQ F (CADR F)))
(T (PRINT (LIST 'BAD '/! 'MACRO C)) (IOC G)))
(RETURN (COND ((SEPARATOR (NXTCHR)) (LIST F NIL))
((ATOM (SETQ C (READ))) (LIST F C))
(T (CONS F C))))))
(DEFUN NXTCHR () (ASCII (TYIPEEK)))
(DEFUN SEPARATOR (CHAR) (MEMQ CHAR '(/ / /) )))
(MAKREADTABLE 'CONNIVREAD)
((LAMBDA (READTABLE)
(SSTATUS MACRO /: 'COLMAC)
(SSTATUS MACRO /, 'COMMAC)
(SSTATUS MACRO /@ 'ATMAC)
(SSTATUS MACRO /! 'EXMAC))
(GET 'CONNIVREAD 'ARRAY))
β ββββββββββββββββββββββββββββββββββββββββ